home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.3 / ice-9 / regex.scm.z / regex.scm
Encoding:
Text File  |  1999-04-16  |  4.6 KB  |  144 lines
  1. ;;;;     Copyright (C) 1997 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ;;;; 
  17.  
  18. ;;;; POSIX regex support functions.
  19.  
  20. (define-module (ice-9 regex))
  21.  
  22. ;;; FIXME:
  23. ;;;   It is not clear what should happen if a `match' function
  24. ;;;   is passed a `match number' which is out of bounds for the
  25. ;;;   regexp match: return #f, or throw an error?  These routines
  26. ;;;   throw an out-of-range error.
  27.  
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. ;;;; These procedures are not defined in SCSH, but I found them useful.
  30.  
  31. (define-public (match:count match)
  32.   (- (vector-length match) 1))
  33.  
  34. (define-public (match:string match)
  35.   (vector-ref match 0))
  36.  
  37. (define-public (match:prefix match)
  38.   (make-shared-substring (match:string match)
  39.              0
  40.              (match:start match 0)))
  41.  
  42. (define-public (match:suffix match)
  43.   (make-shared-substring (match:string match)
  44.              (match:end match 0)))
  45.  
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. ;;;; SCSH compatibility routines.
  48.  
  49. (define-public (regexp-match? match)
  50.   (and (vector? match)
  51.        (string? (vector-ref match 0))
  52.        (let loop ((i 1))
  53.      (cond ((>= i (vector-length match)) #t)
  54.            ((and (pair? (vector-ref match i))
  55.              (integer? (car (vector-ref match i)))
  56.              (integer? (cdr (vector-ref match i))))
  57.         (loop (+ 1 i)))
  58.            (else #f)))))
  59.  
  60. (define-public (regexp-quote regexp)
  61.   (call-with-output-string
  62.    (lambda (p)
  63.      (let loop ((i 0))
  64.        (and (< i (string-length regexp))
  65.         (begin
  66.           (case (string-ref regexp i)
  67.         ((#\* #\. #\( #\) #\+ #\? #\\ #\^ #\$ #\{ #\})
  68.          (write-char #\\ p)))
  69.           (write-char (string-ref regexp i) p)
  70.           (loop (1+ i))))))))
  71.  
  72. (define-public (match:start match . args)
  73.   (let* ((matchnum (if (pair? args)
  74.                (+ 1 (car args))
  75.                1))
  76.      (start (car (vector-ref match matchnum))))
  77.     (if (= start -1) #f start)))
  78.  
  79. (define-public (match:end match . args)
  80.   (let* ((matchnum (if (pair? args)
  81.                (+ 1 (car args))
  82.                1))
  83.      (end (cdr (vector-ref match matchnum))))
  84.     (if (= end -1) #f end)))
  85.  
  86. (define-public (match:substring match . args)
  87.   (let* ((matchnum (if (pair? args)
  88.                (car args)
  89.                0))
  90.      (start (match:start match matchnum))
  91.      (end   (match:end match matchnum)))
  92.     (and start end (make-shared-substring (match:string match)
  93.                       start
  94.                       end))))
  95.  
  96. (define-public (string-match pattern str . args)
  97.   (let ((rx (make-regexp pattern))
  98.     (start (if (pair? args) (car args) 0)))
  99.     (regexp-exec rx str start)))
  100.  
  101. (define-public (regexp-substitute port match . items)
  102.   ;; If `port' is #f, send output to a string.
  103.   (if (not port)
  104.       (call-with-output-string
  105.        (lambda (p)
  106.      (apply regexp-substitute p match items)))
  107.  
  108.       ;; Otherwise, process each substitution argument in `items'.
  109.       (for-each (lambda (obj)
  110.           (cond ((string? obj)   (display obj port))
  111.             ((integer? obj)  (display (match:substring match obj) port))
  112.             ((eq? 'pre obj)  (display (match:prefix match) port))
  113.             ((eq? 'post obj) (display (match:suffix match) port))
  114.             (else (error 'wrong-type-arg obj))))
  115.         items)))
  116.  
  117. (define-public (regexp-substitute/global port regexp string . items)
  118.   ;; If `port' is #f, send output to a string.
  119.   (if (not port)
  120.       (call-with-output-string
  121.        (lambda (p)
  122.      (apply regexp-substitute/global p regexp string items)))
  123.  
  124.       ;; Otherwise, compile the regexp and match it against the
  125.       ;; string, looping if 'post is encountered in `items'.
  126.       (let ((rx (make-regexp regexp)))
  127.     (let next-match ((str string))
  128.       (let ((match (regexp-exec rx str)))
  129.         (if (not match)
  130.         (display str port)
  131.  
  132.         ;; Process all of the items for this match.
  133.         (for-each
  134.          (lambda (obj)
  135.            (cond
  136.             ((string? obj)    (display obj port))
  137.             ((integer? obj)   (display (match:substring match obj) port))
  138.             ((procedure? obj) (display (obj match) port))
  139.             ((eq? 'pre obj)   (display (match:prefix match) port))
  140.             ((eq? 'post obj)  (next-match (match:suffix match)))
  141.             (else (error 'wrong-type-arg obj))))
  142.          items)))))))
  143.  
  144.